
(*
$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
$$$
$$$   PASCAL FILE NAME .................... GP.SAMPLE.TEXT
$$$   PASCAL FILE TYPE .................... TEXT
$$$   PASCAL FILE DATE .................... 1985-MAY-28
$$$
$$$   PASCAL VOLUME NAME .................. GP
$$$
$$$   DISK IMAGE NAME ..................... A2PASDT4
$$$
$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
$$$
$$$   DISK IMAGE COMMENT:
$$$
$$$     APPLE II PASCAL DESKTOP TOOLKIT - PRIMITIVES - 1988 - 4/4
$$$
$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
*)

{^he 'Graphics Primitives Test Program''Page %'}
{^fo '''May 28, 1985'}
{$SETC APPLE:=2}

program test;
   
   uses
      { This may be different for your system. }
      {$u *tk.rel/ints/gp.unit.code }
       grafprims;
   
   
   const
   
      FontSize = 2000;
      BufSize = 8000;
      MyWidth = 40;
      
   type
      
      buf_type = packed array [0..BufSize] of 0..255;
      
      charblock= packed array [0..511] of char;
      
      FontHolder = packed array [0..FontSize] of 0..255;
      
   var
      k,
      ErrorCode,
      PtrToFont
        : integer;
      
      MyBuffer : buf_type;
      
      PtrToData
        : ^charblock;
   
      the_font : font_holder;
      
      x : mapinfo;
      
      myport,
      stdport
        : grafport;
        
      tempfile : file;
      debugfile : text;
   
   procedure LoadFont;
      var
         NoRead
           : integer;
      begin { LoadFont }
         PtrToFont := PointerTo(the_font);
         reset(tempfile, 'test.font');
         moveleft(PtrToFont, PtrToData, 2);
         NoRead:= blockread(tempfile, PtrToData^, 3, 0);
         close(tempfile);
      end; { of LoadFont }
      
  { A couple of procedures useful in debugging }
  procedure     PrintMap(var f : text;
                         var map : mapinfo);
      begin
        writeln(f,'ViewX, ViewY:  ',map.viewloc.x,',',map.viewloc.y);
        writeln(f,'Mapbits:  ',map.mapbits);
        writeln(f,'Mapwidth:  ',map.mapwidth);
        writeln(f,'ClipRect:  ',map.maprect.left,',',map.maprect.top);
        writeln(f,'ClipRect:  ',map.maprect.right,',',map.maprect.bottom);
      end;
  
  
  procedure       PrintPort (var f : text;
                             var p : grafport);
  
  { Prints the values in the port P to the file f }
      var 
          k : integer;
      
      begin
        PrintMap(f,p.portmap);
        write(f,'Pattern:  ');
        for k := 1 to 9 do write(f,p.penpattern[k],', ');
        writeln(f);
        writeln(f,'PenLoc:  ',p.penloc.x,',',p.penloc.y);
        writeln(f,'PenWidth:  ',p.penwidth);
        writeln(f,'PenHeight:  ',p.penheight);
        writeln(f,'PenMode:  ',ord(p.penmode));
        writeln(f,'TextBG:  ',p.textback);
        writeln(f,'TextFont:  ',p.textfont);
      end;

      
   { This is for switching to the buffer }
   
   procedure SetX (var x : mapinfo);
       begin
         with x do 
           begin
             viewloc.x := 0;
             viewloc.y := 0;
             mapbits := pointerto(MyBuffer);
             MapWidth := MyWidth;
             Reserved := 0;
             maprect.top := 0;
             maprect.left := 0;
             maprect.right := 200;
             maprect.bottom := 100;
           end;
       end;
       
   { This is for setting up the viewports that will be used }
   
   procedure SetUpPorts (var Normal,Special : GrafPort);
       begin
         InitPort(Normal);
         InitPort(Special);
         SetX(Special.PortMap);
         Normal.textfont := PtrToFont;
         Special.textfont := PtrToFont;
       end;
      
   { This sets up an easy way to paint a rectangle with one procedure }
   
   procedure My_PaintRect (x1,y1, x2,y2 : integer);
       var
           r : rect;
       begin
         r.top := y1;
         r.left := x1;
         r.bottom := y2;
         r.right := x2;
         paintrect(r);
       end;
       
   { This sets up an easy way to frame a rectangle with just one procedure }
   
   procedure My_FrameRect (x1,y1, x2,y2 : integer);
       var
           r : rect;
       begin
         r.top := y1;
         r.left := x1;
         r.bottom := y2;
         r.right := x2;
         framerect(r);
       end;
       
{ This paints and frame 4 rectangles }

procedure       TryRects;
    begin
      my_paintrect(10,10,30,30);
      my_paintrect(28,28,70,70);
      my_framerect(40,40,90,90);
      my_framerect(100,30,180,60);
      
    end;
    
{ Draws some lines to create a moire pattern }

procedure       TryLines;
    var
        k : integer;
    begin
      setpensize(1,1);
      for k := 0 to 40 do
       begin
         moveto(0,0);
         lineto(560,k*5);
       end;
    end;
    
{ Sets up two polygons and then draws them with a new pattern }

procedure       TryPolys;
    var
      k : integer;
      mypoly : packed record
        count1 : 0..255;
        chain1 : 0..255;
        p1 : array [1..8] of point;
        count2 : 0..255;
        chain2 : 0..255;
        p2 : array [1..3] of point;
      end;
      p,white : pattern;
    
    begin
      with mypoly do
        begin
          count1 := 8;
          chain1 := 128;
          p1[1].x := 64;
          p1[1].y := 168;
          p1[2].x := 192;
          p1[2].y := 168;
          p1[3].x := 224;
          p1[3].y := 120;
          p1[4].x := 288;
          p1[4].y := 120;
          p1[5].x := 320;
          p1[5].y := 168;
          p1[6].x := 448;
          p1[6].y := 168;
          p1[7].x := 320;
          p1[7].y := 40;
          p1[8].x := 192;
          p1[8].y := 40;
          count2 := 3;
          chain2 := 0;  
          p2[1].x := 224;
          p2[1].y :=  96;
          p2[2].x := 288;
          p2[2].y :=  96;
          p2[3].x := 256;
          p2[3].y :=  56;
        end;
    
      for k := 1 to 8 do p[k] := 85; {gray}
      p[9] := 0;
      for k := 1 to 8 do white[k] := 255;
      white[9] := 0;
      
      setpattern(p);
      paintpoly(pointerto(mypoly));
      setpattern(white);
      setpensize(3,3);
      framepoly(pointerto(mypoly));
    end;
    
{ Sets up text to draw on screen }

procedure       TryText;
    var
        k : integer;
    begin
          moveto(4,50);
          drawtext('This a test of the emergency graphics system ');
    end;
    
{ Sets up a bitmap shape then draws it }

procedure       TryBitMaps;
    var
       HandBits : packed array [1..30] of 0..255;
       k : integer;
       Dest : mapinfo;
    
    begin
      for k := 1 to 30 do
        HandBits[k] := 0;
      HandBits[4] := 32 {$20};
      HandBits[7] := 48 {$30};
      Handbits[10] := 56 {$38};
      HandBits[13] := 94 {$5E};
      HandBits[14] := 127 {$7f};
      HandBits[15] := 7   {$07};
      HandBits[16] := 126 {$7e};
      HandBits[19] := 62 {$3E};
      HandBits[20] := 31 {$1f};
      HandBits[22] := 126 {$7e};
      HandBits[25] := 60 {$3c};
      HandBits[26] := 15 {$0f};
      
      Dest.viewloc.x := 50;
      Dest.viewloc.y := 50;
      Dest.mapbits := pointerto(HandBits);
      Dest.mapwidth := 3;
      Dest.maprect.top :=0;
      Dest.maprect.left := 0;
      Dest.maprect.bottom := 9;
      Dest.maprect.right := 17;
      
      paintbits(Dest);
      
 end;
      
{ Get a keypress }

procedure       Do_Readln;
    begin
      gotoxy(0,20);
      readln;
    end;

   procedure   delay1;
   
     begin
       moveto(30,190);
       drawtext('        Drawing into buffer.............');
     
   end;
   
   procedure    cont;
     begin
        moveto(30,190);
        drawtext('  Press RETURN to continue.');
      
  end;
  
   begin { Main Program }
      InitGraf;
      LoadFont;
      SetFont(PtrToFont);
      
      SetUpPorts(StdPort,MyPort);
      
      SetPort(StdPort);
      
      { Draw Some Stuff on the Screen }
      TryRects;
      TryLines;
      TryPolys;
      TryText;
      TryBitMaps;
      
      moveto (30,190);
      drawtext('Press RETURN to continue...');
      do_readln;
      
      
      { Now clear the screen, draw into a buffer and 
        transfer the buffer to the screen }
        
      fillchar(mybuffer,sizeof(mybuffer),chr(0));
      SetX(X);
      
      delay1;
      SetPort(MyPort);
      TryRects;
      SetPort(StdPort);
      PaintBits(x);
      cont;
      write(chr(7));
      do_readln;
      
      fillchar(mybuffer,sizeof(mybuffer),chr(0));
      SetX(X);
      
      delay1;
      SetPort(MyPort);
      TryLines;
      SetPort(StdPort);
      PaintBits(x);
      cont;
      write(chr(7));
      do_readln;
      
      fillchar(mybuffer,sizeof(mybuffer),chr(0));
      SetX(X);
      
      delay1;
      SetPort(MyPort);
      TryPolys;
      SetPort(StdPort);
      PaintBits(x);
      cont;
      write(chr(7));
      do_readln;
      
      fillchar(mybuffer,sizeof(mybuffer),chr(0));
      SetX(X);
      
      delay1;
      SetPort(MyPort);
      TryText;
      SetPort(StdPort);
      PaintBits(x);
      cont;
      write(chr(7));
      do_readln;
      
      fillchar(mybuffer,sizeof(mybuffer),chr(0));
      SetX(X);
      
      delay1;
      SetPort(MyPort);
      TryBitMaps;
      SetPort(StdPort);
      PaintBits(x);
      
      moveto (30,190);
      drawtext('   Press RETURN to quit...   ');
      write(chr(7));
      do_readln;
      
      
   end. { Main Program }
   


(*
$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
$$$   END OF FILE : GP - GP.SAMPLE.TEXT
$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$

File brought to you by:

Apple Macintosh Apple II Pascal Disk Image Dumper 1.0.0 (16 May 2004)
David T Craig (Santa Fe, New Mexico, USA)
shirlgato@cybermesa.com / dcraig@cyberwolf.com

Sunday, June 20, 2004 -- 1:51:56 PM
*)

